* Оболочка экспертной системы.Версия 2.
* База правил находится в файле ExpertSystems2-db.txt 
* Что нового:
* 1) Используется метод прямого и обратного вывода. 
* 2) Обработка отношения ЛИБО между признаками.
* 3) Форма добавления новых правил.
* 4) Просмотр дерева зависимости признаков в графическом режиме.
* Программа КОНЦЕПТ, 17.10.2010-09.04.2011, www.gendoc.ru

*** Начало программы

присвоить ОТСТУП '     '

присвоить ФАЙЛ_БЗ ExpertSystem2-db.txt БАЗА_ЗНАНИЙ "[$ТекущийКаталог][ФАЙЛ_БЗ]"
если (файл существует $результат [БАЗА_ЗНАНИЙ] )
  данные загрузить [БАЗА_ЗНАНИЙ]
иначе
  показать сообщение "Необходимо скачать файл [ФАЙЛ_БЗ] с www.gendoc.ru и поместить его в каталог [$ТекущийКаталог]." 
конец

выбрать (ввести меню1 $результат 'Выберите действие:' 'Показать базу знаний;Интерпретировать базу знаний;Добавить правило;Показать граф базы знаний;Выход' )
  вариант 'Показать базу знаний'
    Показать_базу_знаний
  вариант 'Интерпретировать базу знаний'
    Интерпретировать_базу_знаний
  вариант 'Добавить правило'
    Добавить_правило
  вариант 'Показать граф базы знаний'
    Показать_граф_базы_знаний
конецВыбора

если [$ДанныеИзменены]
  данные сохранить [БАЗА_ЗНАНИЙ]
конец

*** Функции логического вывода

функция Интерпретировать_базу_знаний
память локальный гипотеза решение_найдено

  присвоить ПРОТОКОЛ_ВОПРОСОВ {}

  показать сообщение 'Загадайте животное и откровенно отвечайте на вопросы.'
  Протокол 'Протокол логического вывода.'

  Подготовка_к_логическому_выводу
  присвоить решение_найдено [$ложь]

  для [ТЕРМИНАЛЬНЫЕ_СЛЕДСТВИЯ]
    присвоить гипотеза [$объектЦикла]
    если (Доказать_гипотезу [гипотеза] 0 )
      присвоить решение_найдено [$истина]
      присвоить $списокЦикла {} 
    конец
  следующий

  Протокол '' 
  Протокол "Отработавшие правила: [ОТРАБОТАВШИЕ_ПРАВИЛА]."

  если [решение_найдено]
    показать сообщение "Это [гипотеза]!" 
  иначе
    показать сообщение 'Решение не найдено.'
  конец

  Протокол '' 
  Протокол 'Итоговый протокол.' 
  для [ПРОТОКОЛ_ВОПРОСОВ]
    Протокол [$ОбъектЦикла]
  следующий
  если [решение_найдено]
    Протокол "Это [гипотеза]!" 
  иначе
    Протокол 'Решение не найдено.'
  конец
возврат

функция Подготовка_к_логическому_выводу
  список кМножеству ВСЕ_СЛЕДСТВИЯ (факт домен $результат правило <следствие> )
  список кМножеству ВСЕ_УСЛОВИЯ (список терминальные $результат (факт домен $результат правило <условие> ) )
  множество разность ТЕРМИНАЛЬНЫЕ_СЛЕДСТВИЯ [ВСЕ_СЛЕДСТВИЯ] [ВСЕ_УСЛОВИЯ]
  множество разность ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ [ВСЕ_УСЛОВИЯ] [ВСЕ_СЛЕДСТВИЯ]
  факт сопоставить ВСЕ_ПРАВИЛА r;правило;[?];[?]
  присвоить ОТРАБОТАВШИЕ_ПРАВИЛА {}
возврат

функция Доказать_И гипотезы глубина
  память локальный доказано подцель

  присвоить доказано [$истина]

* Если ранее установлено, что одна из посылок ложна, то и вся гипотеза ложна
  для [гипотезы]
    если (память существует $результат "УСТАНОВЛЕНО;[$ОбъектЦикла]" )
      если [УСТАНОВЛЕНО;[$ОбъектЦикла]] == нет
        присвоить доказано [$ложь]
        Протокол "[ОТСТУП]Ранее было установлено, что [$ОбъектЦикла] ЛОЖНО."
      конец
    конец
  следующий

  если [доказано]
    для [гипотезы]
      присвоить подцель [$ОбъектЦикла]
      присвоить доказано (Доказать_гипотезу [подцель] [глубина] )
      если [доказано]
      иначе
        присвоить $списокЦикла {}
      конец
    следующий
  конец

  присвоить $результат [доказано]
возврат

функция Доказать_ИЛИ гипотеза глубина
  память локальный доказано правила список_подцелей

  присвоить доказано [$ложь]
  факт сопоставить правила "r;правило;[гипотеза];[?]"
  для [правила]
    Протокол "[ОТСТУП]Применение Правила N [$объектЦикла] для '[гипотеза]'."
    список взять список_подцелей (факт взять $результат [$объектЦикла] ) 4
    присвоить доказано (Доказать_И [список_подцелей] [глубина] )
    если [доказано]
      список сцепить ОТРАБОТАВШИЕ_ПРАВИЛА $ [$объектЦикла]
      присвоить $списокЦикла {}
    конец
  следующий

  присвоить $результат [доказано]
возврат 

функция Доказать_гипотезу гипотеза глубина
  память локальный доказано правила вывод

  увеличить глубина
  если [глубина] = 1
    Протокол ''
    Протокол "([глубина]) ГИПОТЕЗА: [гипотеза]."
  иначе
    Протокол "([глубина]) ПОДЦЕЛЬ: [гипотеза]."
  конец

  присвоить доказано [$ложь]

* 1) Промежуточная гипотеза может быть уже доказана
  если (память существует $результат "УСТАНОВЛЕНО;[гипотеза]" )
    если [УСТАНОВЛЕНО;[гипотеза]] == да
      присвоить доказано [$истина]
    иначе
      *** Пропускаем, если [УСТАНОВЛЕНО;[гипотеза]] == нет

    конец
  иначе
* 2) Гипотеза может быть безусловно истинной
    факт сопоставить правила "r;правило;[гипотеза];{}"
    если [правила]
      присвоить доказано [$истина]
    конец
* 3) Может потребоваться запросить пользователя
  если (множество и $результат [ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ] [гипотеза] )
    присвоить доказано (Запросить_пользователя [гипотеза] )
  иначе
* 4) Поиск и применение правил, в которых гипотеза является следствием
    присвоить доказано (Доказать_ИЛИ [гипотеза] [глубина] )
  конец
  конец
  конец

  если [доказано]
    присвоить "УСТАНОВЛЕНО;[гипотеза]" да    
    Обработать_ЛИБО [гипотеза]
  конец

  если [доказано]
    присвоить вывод ИСТИНА
  иначе
    присвоить вывод ЛОЖЬ
  конец
  Протокол "([глубина]) [гипотеза] ===> [вывод]."

  присвоить $результат [доказано]
возврат

функция Обработать_ЛИБО гипотеза
память локальный список_фактов успешно множество_взаимоисключающих

множество и список_фактов \
  (факт понятие $результат либо ) \
  (факт понятие $результат [гипотеза] )

для [список_фактов]
  если (множество и $результат [ОТРАБОТАВШИЕ_ПРАВИЛА] [$ОбъектЦикла] ) == {}
    список сопоставить успешно (факт взять $результат [$ОбъектЦикла] ) "r;либо;[?множество_взаимоисключающих]"
    если (множество и $результат [множество_взаимоисключающих] [гипотеза] )
      для (множество разность $результат [множество_взаимоисключающих] [гипотеза] )
        присвоить "УСТАНОВЛЕНО;[$ОбъектЦикла]" нет    
        Протокол "[ОТСТУП]УСТАНОВЛЕНО, ЧТО НЕ: [$ОбъектЦикла]."
      следующий
      список сцепить ОТРАБОТАВШИЕ_ПРАВИЛА $ [$ОбъектЦикла]
    конец
  конец
следующий

возврат

функция Запросить_пользователя гипотеза
  память локальный ответ_пользователя 

  множество разность ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ [ТЕРМИНАЛЬНЫЕ_УСЛОВИЯ] [гипотеза]
  ввести меню1 ответ_пользователя "[гипотеза]?" 'да;нет;не знаю'
  если [ответ_пользователя] == ''
    присвоить ответ_пользователя 'не знаю'
  конец
  Протокол "[ОТСТУП]ВОПРОС: [гипотеза]? [ответ_пользователя]."
  список сцепить ПРОТОКОЛ_ВОПРОСОВ $ "  [гипотеза]? [ответ_пользователя]."
  если [ответ_пользователя] == да
    присвоить $результат [$истина]
  иначе
    присвоить $результат [$ложь]
  конец     
возврат

функция Протокол текст
  >[текст]
возврат

*** Функции для просмотра базы знаний

функция Показать_базу_знаний
  память локальный номер_факта
  печать '' 'База знаний.' ========= ''
  присвоить номер_факта 1
  пока [номер_факта] <= [$количествоФактов]
    Показать_правило [номер_факта]
    увеличить номер_факта
  цикл
возврат

функция Показать_правило номер
  память локальный успешно условие следствие условие_текст

  список сопоставить успешно (факт взять $результат [номер] ) r;правило;[?следствие];[?условие]
  если [успешно]
    присвоить условие_текст ''
    для [условие]
      если [условие_текст]  == ''
        присвоить условие_текст [$объектЦикла]
      иначе
        присвоить условие_текст "[условие_текст] И [$объектЦикла]"
      конец
    следующий

    >Правило N [номер].
    если [условие] != {}
      печать "ЕСЛИ [условие_текст]," "  ТО [следствие]."
    иначе
      >ИЗВЕСТНО, ЧТО [следствие].
    конец
    >
  иначе
    список сопоставить успешно (факт взять $результат [номер] ) r;либо;[?следствие]
    если [успешно]
      строка заменитьПодстроку следствие $ ';' ' ЛИБО '
      >Правило N [номер].
      >ЛИБО [следствие].
      >
    конец
  конец
возврат

*** Функции пополнения базы знаний

функция Добавить_правило
память локальный Все_условия_и_следствия Новое_правило условие факт

множество или Все_условия_и_следствия \ 
  (факт домен $результат правило <условие> ) \
  (факт домен $результат правило <следствие> )
список терминальные Все_условия_и_следствия $
список кМножеству Все_условия_и_следствия $

данные использовать 2
данные новый
для [Все_условия_и_следствия]
  факт добавить \
    "i;[$ОбъектЦикла];условие 1" \
    "i;[$ОбъектЦикла];условие 2" \
    "i;[$ОбъектЦикла];условие 3" \
    "i;[$ОбъектЦикла];условие 4" \
    "i;[$ОбъектЦикла];условие 5" \
    "i;[$ОбъектЦикла];заключение"
следующий

ввести форма Новое_правило 'Введите правило (Ctrl - подстановка значения из списка):' 'условие 1;условие 2;условие 3;условие 4;условие 5;заключение'
данные использовать 1

присвоить ОШИБКА ''
если (память существует $результат Новое_правило;заключение )
* Условия правила 
  присвоить условие {}
  для 1;2;3;4;5
    если [Новое_правило;условие [$ОбъектЦикла]]
      множество или условие $ [Новое_правило;условие [$ОбъектЦикла]]
    конец
  следующий
  если [условие] == {}
    строка сцепить ОШИБКА $ 'Условие для правила не определено.'
  конец

* Заключение правила
  если [Новое_правило;заключение]
  иначе
    строка сцепить ОШИБКА $ 'Заключение для правила не определено.'
  конец

* Другие проверки
  если (множество и $результат [условие] [Новое_правило;заключение] )
    строка сцепить ОШИБКА $ 'Заключение правила не может появляться в его условиях.'
  конец
иначе
    строка сцепить ОШИБКА $ 'Заключение для правила не определено.' 
конец

если [ОШИБКА]
  показать сообщение "Правило не добавлено: [ОШИБКА]"
иначе
  список присоединить факт "r;правило;[Новое_правило;заключение]" [условие]
  факт добавить [факт]
  Показать_правило (факт найти $результат [факт] )
конец

возврат

*** Функции для показа базы знаний в виде графа

функция Показать_граф_базы_знаний
  память локальный начальная_вершина

  Подготовка_к_логическому_выводу
  ввести переменная начальная_вершина 'Показать граф для:' [ВСЕ_СЛЕДСТВИЯ]
  если [начальная_вершина]
    данные использовать 2
    данные новый
    факт добавить s;вершина;обозначение_вершины;координаты_вершины s;ребро;обозначение_вершины_1;обозначение_вершины_2
    данные использовать 1

    присвоить ПРОСМОТРЕННЫЕ_ВЕРШИНЫ {} КОЛОНКА 0   
    Построить_И_ИЛИ_дерево [начальная_вершина] 0

    присвоить ШАГ_РЕШЕТКИ_ШИРИНА 120 ШАГ_РЕШЕТКИ_ВЫСОТА 100
    присвоить ПОЛОВИНА_ШИРИНЫ_ВЕРШИНЫ 50 ПОЛОВИНА_ВЫСОТЫ_ВЕРШИНЫ 40
    присвоить ЦВЕТ_ВЕРШИНЫ 15 ЦВЕТ_РЕБРА 1 РАЗМЕР_ТЕКСТА 9

    данные использовать 2  
    Показать_граф
    данные использовать 1
  конец
возврат

функция Построить_И_ИЛИ_дерево вершина глубина
  увеличить глубина

  если (множество и $результат [ПРОСМОТРЕННЫЕ_ВЕРШИНЫ] [вершина] ) == {}
    множество или ПРОСМОТРЕННЫЕ_ВЕРШИНЫ $ [вершина]
  
    *** Добавление вершины в граф
    данные использовать 2
    увеличить КОЛОНКА  
    факт добавить "r;вершина;[вершина];{[КОЛОНКА];[глубина]}"
    данные использовать 1

    для (факт сопоставить $результат "r;правило;[вершина];[?]" )
      для (список взять $результат (факт взять $результат [$ОбъектЦикла] ) 4 ) 
       
        *** Добавление ребра в граф
        данные использовать 2
        факт добавить "r;ребро;[вершина];[$ОбъектЦикла]"
        данные использовать 1

        Построить_И_ИЛИ_дерево [$ОбъектЦикла] [глубина]
      следующий
    следующий
  конец
возврат

функция Показать_граф
  память локальный номер_факта Вершина1 Вершина2 Наименование1 Наименование2

* Рисование ребер графа
  присвоить $цветЛинии [ЦВЕТ_РЕБРА] $толщинаЛинии 1
  присвоить номер_факта 1
  пока [номер_факта] <= [$КоличествоФактов]
    если (список сопоставить $результат (факт взять $результат [номер_факта] ) "r;ребро;[?Наименование1];[?Наименование2]" )
      факт сопоставитьСПервым успешно "r;вершина;[Наименование1];[?Вершина1]"
      факт сопоставитьСПервым успешно "r;вершина;[Наименование2];[?Вершина2]"
      Рисовать_линию [Вершина1] [Вершина2]
    конец
    увеличить номер_факта
  цикл

* Рисование вершин графа
  присвоить $цветЛинии [ЦВЕТ_ВЕРШИНЫ] $цветКисти [ЦВЕТ_ВЕРШИНЫ] $размерТекста [РАЗМЕР_ТЕКСТА]
  присвоить номер_факта 1
  пока [номер_факта] <= [$КоличествоФактов]
    если (список сопоставить $результат (факт взять $результат [номер_факта] ) "r;вершина;[?Наименование1];[?Вершина1]" )
      Рисовать_вершину [Наименование1] [Вершина1]
    конец
    увеличить номер_факта
  цикл
возврат

функция Рисовать_вершину наименование вершина 
  память локальный ширина высота ширина0 высота0 ширина1 высота1 ширина2 высота2
  список сопоставить _ [вершина] "[?ширина];[?высота]"
  вычислить * ширина0 [ширина] [ШАГ_РЕШЕТКИ_ШИРИНА]
  вычислить * высота0 [высота] [ШАГ_РЕШЕТКИ_ВЫСОТА]
  вычислить - ширина1 [ширина0] [ПОЛОВИНА_ШИРИНЫ_ВЕРШИНЫ]
  вычислить - высота1 [высота0] [ПОЛОВИНА_ВЫСОТЫ_ВЕРШИНЫ]
  вычислить + ширина2 [ширина0] [ПОЛОВИНА_ШИРИНЫ_ВЕРШИНЫ]
  вычислить + высота2 [высота0] [ПОЛОВИНА_ВЫСОТЫ_ВЕРШИНЫ]  
  рисовать прямоугольник [ширина1] [высота1] [ширина2] [высота2]
  рисовать текстВПрямоугольнике [ширина1] [высота1] [ширина2] [высота2] [наименование]
возврат

функция Рисовать_линию вершина1 вершина2
  память локальный ширина1 высота1 ширина2 высота2
  список сопоставить _ [вершина1] "[?ширина1];[?высота1]"
  список сопоставить _ [вершина2] "[?ширина2];[?высота2]"
  вычислить * ширина1 $ [ШАГ_РЕШЕТКИ_ШИРИНА]
  вычислить * высота1 $ [ШАГ_РЕШЕТКИ_ВЫСОТА]
  вычислить * ширина2 $ [ШАГ_РЕШЕТКИ_ШИРИНА]
  вычислить * высота2 $ [ШАГ_РЕШЕТКИ_ВЫСОТА]
  рисовать линия [ширина1] [высота1] [ширина2] [высота2]
возврат